home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1994 December / PSL Monthly Shareware CD-ROM (Public Software Library)(December 1994).bin / prgmming / dos / pascal3 / heap7.pas < prev    next >
Pascal/Delphi Source File  |  1993-02-22  |  6KB  |  144 lines
  1. UNIT HEAP7;
  2. { ******************************************************************* }
  3. { HEAP7.PAS = Protected Mode Mark/Release!                            }
  4. {                                                                     }
  5. { This Unit implements a protected mode heap supporting Mark, GetMem, }
  6. { and Release. NEW can be simulated with GetMem(pVar, Sizeof(pVar^)), }
  7. { where pVar can be a pointer to an array or record, but of course,   }
  8. { it *CANNOT* be a pointer to an object!                              }
  9. {                                                                     }
  10. { A program can simultaniously use the heap provided by this unit and }
  11. { the SYSTEM heap. Since the SYSTEM supports all forms of NEW/DISPOSE }
  12. { and GETMEM/FREEMEM, you can take the best from both worlds.         }
  13. {                                                                     }
  14. { The Heap is initialized by calling HEAP7.Init(Low, High, Reserved), }
  15. { and released by calling HEAP7.Done.  Init and Done are intellegent  }
  16. { enough to be called out-of-turn. Calling Init twice w/o calling     }
  17. { Done will automatically call Done before performing the 2nd Init.   }
  18. { When Init is called the first time, the links are placed to cause   }
  19. { Done to be called as part of the stardard exit procedure.           }
  20. {                                                                     }
  21. { I chose to keep the names GetMem, Mark, Release, MaxAvail, thereby  }
  22. { making it relatively easy to convert an older program. Should both  }
  23. { heaps be used within a program, the procedures may be qualified     }
  24. { using SYSTEM.GetMem and HEAP7.GetMem. Of course you can rename the  }
  25. { procedures to something else if you prefer...                       }
  26. {                                                                     }
  27. { Mark, GetMem, and Release are simple, yet even with error checking, }
  28. { they are capable of destroying the heap at your request. If you     }
  29. { are really interested in watching the sparks fly you might release  }
  30. { a pointer that wasn't obtained by HEAP7's Mark/GetMem procedures,   }
  31. { maybe an uninitialized one, or one obtained from the SYSTEM. Then   }
  32. { again you could feed the SYSTEM FreeMem or Dispose the 1st pointer  }
  33. { you obtained from HEAP7's GetMem or Mark. Either way the results    }
  34. { should be quite interesting <g>.                                    }
  35. {                                                                     }
  36. { Enjoy.    ...red                                                    }
  37. {                                            Roger Donais [70414,524] }
  38. { ******************************************************************* }
  39. INTERFACE
  40.  
  41. PROCEDURE Init(LowerLimit, UpperLimit, Reserve: Longint);
  42. PROCEDURE Done;
  43. FUNCTION  MaxAvail: Longint;
  44. PROCEDURE Mark(VAR P: Pointer);
  45. PROCEDURE Release(VAR p: Pointer);
  46. PROCEDURE GetMem(VAR p: Pointer; Size: Word);
  47.  
  48. { ******************************************************************* }
  49. IMPLEMENTATION
  50. USES WinAPI;
  51.  
  52. TYPE Long = RECORD Lo, Hi: Word; END;
  53. CONST HeapBase: Pointer = NIL;
  54.       HeapTop : Longint = 0;
  55.       HeapSize: Longint = 0;
  56.  
  57.  
  58. FUNCTION  MaxAvail: Longint;
  59. { ------------------------------------------------------------------- }
  60. BEGIN
  61.     MaxAvail := HeapSize - HeapTop;
  62. END;
  63.  
  64.  
  65. PROCEDURE Mark(VAR P: Pointer);
  66. { ------------------------------------------------------------------- }
  67. BEGIN
  68.     {$IFOPT R+}
  69.         If NOT(Assigned(HeapBase)) Then
  70.            RunError(203);
  71.     {$ENDIF}
  72.     p := Ptr(Long(HeapTop).Hi * SelectorInc + Seg(HeapBase^), Long(HeapTop).Lo);
  73. END;
  74.  
  75.  
  76. PROCEDURE Release(VAR p: Pointer);
  77. { ------------------------------------------------------------------- }
  78. BEGIN
  79.     {$IFOPT R+}
  80.         If NOT(Assigned(HeapBase))
  81.         or (Seg(p^) < Seg(HeapBase^))
  82.         or (Seg(p^) > Long(HeapSize).Hi * SelectorInc + Seg(HeapBase^)) Then
  83.            RunError(204);
  84.     {$ENDIF}
  85.     Long(HeapTop).Lo := Ofs(p^);
  86.     Long(HeapTop).Hi := (Seg(p^) - Seg(HeapBase^)) div SelectorInc;
  87. END;
  88.  
  89.  
  90. PROCEDURE GetMem(VAR p: Pointer; Size: Word);
  91. { ------------------------------------------------------------------- }
  92. VAR i: Longint;
  93. BEGIN
  94.     If Long(HeapTop).Hi <> HiWord(HeapTop + Pred(Size)) Then Begin
  95.         Inc(Long(HeapTop).Hi);
  96.         Long(HeapTop).Lo := 0;
  97.     End;
  98.     If HeapTop + Size > HeapSize Then
  99.        RunError(203);
  100.  
  101.     p := Ptr(Long(HeapTop).Hi * SelectorInc + Seg(HeapBase^), Long(HeapTop).Lo);
  102.     Inc(HeapTop, Size);
  103. END;
  104.  
  105.  
  106. CONST TurboExitProc: Pointer = NIL;
  107. PROCEDURE AtExit; FAR;
  108. { ------------------------------------------------------------------- }
  109. BEGIN
  110.     ExitProc := TurboExitProc;
  111.     TurboExitProc := NIL;         { Set NIL incase recovery occurs... }
  112.     Done;
  113. END;
  114.  
  115.  
  116. PROCEDURE Init(LowerLimit, UpperLimit, Reserve: Longint);
  117. { ------------------------------------------------------------------- }
  118. BEGIN
  119.     Done;
  120.     If NOT Assigned(TurboExitProc) Then Begin
  121.        TurboExitProc := ExitProc;
  122.        ExitProc := @AtExit;
  123.     End;
  124.     HeapSize := (SYSTEM.MaxAvail - Reserve);
  125.     If HeapSize > UpperLimit Then HeapSize := UpperLimit;
  126.     If HeapSize < LowerLimit Then RunError(8);
  127.     HeapBase := GlobalAllocPtr(GMEM_FIXED, HeapSize);
  128.     HeapTop := 0;
  129. END;
  130.  
  131.  
  132. PROCEDURE Done;
  133. { ------------------------------------------------------------------- }
  134. BEGIN
  135.     If Assigned(HeapBase) Then Begin
  136.        GlobalFreePtr(HeapBase);
  137.        HeapBase := NIL;
  138.        HeapTop  := 0;
  139.        HeapSize := 0;
  140.     End;
  141. END;
  142.  
  143. END.
  144.